home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / rule-ants.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  10.3 KB  |  261 lines  |  [TEXT/CCL2]
  1. ;; -*- mode:lisp; syntax:common-lisp; package:cl-user -*-
  2. ;; file    : rule-ants.lisp
  3. ;; author  : Adam Alpern (ala@neural.hampshire.edu)
  4. ;; created : 07/16/94
  5. ;; version : 0.2
  6. ;; copyright: This particular implementation is ©1994 Adam Alpern.
  7. ;; synopsis: Something I whipped up in an evening after reading about 
  8. ;;           a neat little ant in "Mathematical Recreations".
  9. ;;         This is just something I coded up very quickly because I
  10. ;;         thought it would be easy and fun. Enjoy!
  11. ;;         If you have any comments, suggestions, improvements, or
  12. ;;         whatever, please send the to me at ala@neural.hampshire.edu.
  13. ;;
  14. ;; Langton's Ant:
  15. ;;   Langton's ant is a very simple-minded creature in a simple world.
  16. ;; The antworld consists of a square grid, with each square in the grid 
  17. ;; being either white or black (impl. note: squares which have not yet
  18. ;; been visted by the ant are colored gray. They are treated as if they 
  19. ;; were white). The ant starts at an arbitrary point in the grid, with an 
  20. ;; arbitrary heading, say east. The ant moves one square in it's direction.
  21. ;; If the square it lands on is black, the ant colors it white and turns 90
  22. ;; degrees to the left. If the square is white, the ant colors it black and
  23. ;; turns 90 degrees to the right. The neat part is, after around 10,000 
  24. ;; steps, the ant will start building a highway!
  25. ;;
  26. ;; Rule Ants
  27. ;;   The case of Langton's Ant may be generalized to ants which may have
  28. ;; an arbitrary rule-string composed of 1s and 0s. When an ant with a 
  29. ;; rule-string with a length of n leaves a cell with color k, it increments 
  30. ;; the color of the cell to k + 1, wrapping k = (n - 1) + 1 to 0, and then
  31. ;; turns left or right based on the value of the kth symbol in the rule-string.
  32. ;; If the kth symbol is 1, the ant turns 90 degrees to the right. If it is
  33. ;; 0, the nt turns 90 degrees to the left. Then it moves on to the next cell
  34. ;; and repeats.
  35. ;;
  36. ;; References
  37. ;; [1] Stewart, Ian "The Ultimate in Anty-Particles" in the Mathematical
  38. ;; Recreations column, Scientifc American, July 1994.  
  39. ;;
  40. ;; Notes
  41. ;; Does no error-checking. If the ant happens to wander off the
  42. ;; edge of the grid, it will cause an array index out of bounds error.
  43. ;;
  44. ;; The classes ant, antworld, and ant-window should never be directly
  45. ;; created with make-instance. Instead, use make-antworld to create
  46. ;; the whole package.
  47. ;;
  48. ;; Usage
  49. ;; [function] make-antworld => (w ant-window)
  50. ;; make-antworld returns an instance of the class ant-window. 
  51. ;; keyword args:
  52. ;;    :x      integer    The horizontal size of the world.
  53. ;;    :y      integer    The vertical size of the world.
  54. ;;    :cellsize integer    The size in pixels of a side of a cell.
  55. ;;    :ant-x      integer    The horizontal location of the ant's 
  56. ;;                 initial position.
  57. ;;    :ant-y      integer    The vertical location of the ant's 
  58. ;;                 initial position.
  59. ;;    :heading  { $east | $west | $north | $south }    
  60. ;;    :rule      a string containing only 1s and 0s, i.e. "1100"
  61. ;;    :colors      a 1-dimensional array of MCL encoded colors,
  62. ;;          equal in size or greater than the length of
  63. ;;          the rule-string
  64. ;;
  65. ;; [method] run ((w ant-window) &optional (length :infinite)) => nil
  66. ;; Runs the ant in the world contained within the ant-window by calling
  67. ;; move-ant succesively on the ant. Returns nil. 
  68. ;; Takes one optional argument:
  69. ;;    length        { :infinite | an integer } Runs until aborted
  70. ;;            if length is :inifinte (the default), or else
  71. ;;            executes the specified number of moves. If
  72. ;;            is supplied, it must be either :infinite or
  73. ;;            an integer. 
  74. ;;
  75. ;; Revision History
  76. ;; 07/16/94    - file created, based on langtons-ant.lisp
  77. ;;
  78. ;; Example
  79. ;; This example gives the behaviour of Langton's ant using the
  80. ;; default values.
  81. ;; (setf foo (make-antworld))
  82. ;; (run foo)
  83. ;;
  84. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85.  
  86. (in-package :cl-user)
  87. (require :quickdraw)
  88.  
  89. (defconstant $east  (list 'x 1))
  90. (defconstant $west  (list 'x -1))
  91. (defconstant $north (list 'y -1))
  92. (defconstant $south (list 'y 1))
  93.  
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95.  
  96. (defclass ant ()
  97.   ((x :initarg :x :initform 75 :accessor x) 
  98.    (y :initarg :y :initform 75 :accessor y)
  99.    (heading :initarg :heading :initform $east :accessor heading)
  100.    (world   :initarg :world   :initform nil   :accessor world)
  101.    (rule    :initarg :rule    :initform "10"  :accessor rule)
  102.    (colors  :initarg :colors  :initform #(0 16777215)
  103.             :accessor colors)))
  104.  
  105. (defclass antworld (view)
  106.   ((x :initarg :x :initform 150 :accessor x)
  107.    (y :initarg :y :initform 150 :accessor y)
  108.    (grid     :initarg :grid     :initform nil :accessor grid)
  109.    (ant      :initarg :ant      :initform nil :accessor ant)
  110.    (cellsize :initarg :cellsize :initform 2   :accessor cellsize)
  111.    (name     :initarg :name     :initform (gensym "antworld-") :accessor name)))
  112.  
  113. (defclass ant-window (window) 
  114.   ((world :initarg :world :initform nil :accessor world)
  115.    (name  :initarg :name  :initform (gensym "ant-window-") :accessor name))
  116.   (:default-initargs :color-p t :grow-icon-p nil))
  117.  
  118. (defmethod ant ((w ant-window))
  119.   (ant (world w)))
  120.  
  121. (defmethod run ((w ant-window) &optional (length :infinite))
  122.   (cond ((equal length :infinite) 
  123.          (loop (move-ant (ant w))))
  124.         ((numberp length)
  125.          (dotimes (i length)
  126.            (move-ant (ant w))))))
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129.  
  130. (defmethod initialize-instance :after ((w antworld) &rest args)
  131.   (declare (ignore args))
  132.   (set-view-size w (* (cellsize w) (x w)) (* (cellsize w) (y w)))
  133.   (setf (grid w) (make-array (list (x w) (y w)) 
  134.                              :initial-element 0)))
  135.  
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137.  
  138. (defmethod view-draw-contents ((w antworld))
  139.   (with-focused-view w
  140.     (with-fore-color *Light-Gray-Color*
  141.       (fast-paint-rect 0 0 (point-h (view-size w)) (point-v (view-size w))
  142.                        *Light-Gray-Color*))))
  143.  
  144. (defun fast-paint-rect (left &optional top right bot color)
  145.   "A version of PAINT-RECT that does not focus the view -- should only
  146. be called within a WITH-FOCUSED-VIEW."
  147.   (with-fore-color color
  148.     (ccl::with-rectangle-arg (r left top right bot) (#_PaintRect r))))
  149.  
  150. (defun draw-cell (w x y colors)
  151.   (with-focused-view w
  152.     (fast-paint-rect (* x (cellsize w)) (* y (cellsize w))
  153.                          (+ (* x (cellsize w)) (cellsize w)) 
  154.                          (+ (* y (cellsize w)) (cellsize w)) 
  155.                          (aref colors (aref (grid w) x y)))))
  156.  
  157. (defun increment-cell (w x y rule)
  158.   (setf (aref (grid w) x y) 
  159.         (mod (+ 1 (aref (grid w) x y))
  160.              (length rule))))
  161.  
  162. (defun increment-and-draw-cell (w x y colors rule)
  163.   (increment-cell w x y rule)
  164.   (draw-cell w x y colors))
  165.  
  166. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  167.  
  168. (defun make-antworld (&key (x 150) (y 150) (cellsize 2) 
  169.                            (ant-x 75) (ant-y 75)
  170.                            (rule "10")
  171.                            (heading $east)
  172.                            (colors #(0 16777215)))
  173.   "This should always be called to create a new antworld. ants, antworlds,
  174. and ant-windows should never be directly instatiated with make-instance."
  175.   (let (a w wind)
  176.     (setq w (make-instance 'antworld :x x :y y :cellsize cellsize))
  177.     (setq a (make-instance 'ant :world w :x ant-x :y ant-y
  178.                            :heading heading
  179.                            :colors colors
  180.                            :rule rule))
  181.     (setf (ant w) a)
  182.     (setf (world a) w)
  183.     (setq wind (make-instance 'ant-window :world w))
  184.     (set-view-size wind (* (cellsize w) (x w)) (* (cellsize w) (y w)))
  185.     (set-window-title wind (princ-to-string (name w)))
  186.     (add-subviews wind w)
  187.     wind))
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.  
  191. (defun move-ant (ant)
  192.   (let ((world (world ant))                ; the ants' world
  193.         (k (aref (grid (world ant)) (x ant) (y ant))))    ; the color/rule index
  194.         
  195.     (increment-and-draw-cell world (x ant) (y ant)    ; increment the
  196.                              (colors ant) (rule ant))    ; vacated cell
  197.         
  198.     (case (elt (rule ant) k)    ; change the ants' heading appropriately
  199.       (#\0             ; 0 : turn left 90 degrees
  200.        (cond
  201.         ((equalp (heading ant) $east)  (setf (heading ant) $north))
  202.         ((equalp (heading ant) $west)  (setf (heading ant) $south))
  203.         ((equalp (heading ant) $north) (setf (heading ant) $west))
  204.         ((equalp (heading ant) $south) (setf (heading ant) $east))))
  205.       (#\1             ; 1 : turn right 90 degrees
  206.        (cond 
  207.         ((equalp (heading ant) $east)  (setf (heading ant) $south))
  208.         ((equalp (heading ant) $west)  (setf (heading ant) $north))
  209.         ((equalp (heading ant) $north) (setf (heading ant) $east))
  210.         ((equalp (heading ant) $south) (setf (heading ant) $west)))))
  211.  
  212.     (if (equalp (first (heading ant)) 'x)        ; move the ant
  213.       (setf (x ant) (+ (x ant) (second (heading ant))))    ; in the appropriate
  214.       (setf (y ant) (+ (y ant) (second (heading ant))))); direction
  215.  
  216.     ))
  217.  
  218. #|
  219.  
  220. (defun make-gray-gradient ()
  221.   (let ((step 255)
  222.         (gradient (make-array 256)))
  223.     (dotimes (i 256)
  224.       (setf (aref gradient i)
  225.             (make-color (* step i) (* step i) (* step i))))
  226.     gradient))
  227.  
  228. ;; this ant uses 256 shades of grey and a 256 symbol rule-string
  229. ;; made of a repeated 4-symbol rule, and generates bilaterally 
  230. ;; symmetrical patterns.
  231.  
  232. (setf florgle (make-antworld 
  233.            :rule (concatenate 'string
  234.                               "11001100110011001100110011001100"
  235.                               "11001100110011001100110011001100"
  236.                               "11001100110011001100110011001100"
  237.                               "11001100110011001100110011001100"
  238.                               "11001100110011001100110011001100"
  239.                               "11001100110011001100110011001100"
  240.                               "11001100110011001100110011001100"
  241.                               "11001100110011001100110011001100")
  242.            :colors (make-gray-gradient)
  243.            :cellsize 1
  244.            :heading $east))
  245. (run florgle :infinite)
  246.  
  247. ;; Ant 1100 creates infinitely many bilaterally
  248. ;; symmetrical patterns
  249. (setf baz (make-antworld 
  250.            :rule "1100"
  251.            :colors `#(,*black-Color* ,*gray-Color* 
  252.                                      9474192 ,*white-Color*)
  253.            :cellsize 2
  254.            :heading $east))
  255. (run baz 10000)
  256.  
  257. ;; Langton's Ant
  258. (progn (setf bar (make-antworld))
  259.        (run bar))
  260.  
  261. |#